perm filename GEMFIX.LSP[GEL,BGB] blob sn#239339 filedate 1976-10-05 generic text, type T, neo UTF8
(DEFPROP GEMFIXFNS
 (GEMFIXFNS GEMSETQ
	    LISPSETQ
	    COMMENT
	    ENTER
	    SETQ
	    *ERRORX
	    GEMFIX
	    LISP
	    ERRORX
	    GEMTOP
	    XWC/.
	    YWC/.
	    ZWC/.
	    (COND ((ERRSET GEMVARS NIL) NIL) (T (SETQ GEMVARS NIL)))
	    (COMMENT (MODCHR (CHRVAL (QUOTE /.)) (MODCHR (CHRVAL (QUOTE A)) NIL))))
VALUE)

(DEFPROP COMMENT
 (LAMBDA(L) NIL)
EXPR)

(DEFPROP ENTER
 (LAMBDA (X L) (COND ((MEMBER X L) L) (T (CONS X L))))
EXPR)

(DEFPROP GEMSETQ
 (LAMBDA(X Y)
  (PROG2 (DEPOSIT (MAKNUM (CDDR X))
		  (COND	((EQ (CADR X) (QUOTE FIXNUM)) (FIX Y))
			(T (MAKNUM (NUMVAL (*PLUS Y 0)) (QUOTE FIXNUM)))))
	 Y))
EXPR)

(DEFPROP LISPSETQ
 (LAMBDA (L) (PROG2 (PUTPROP (QUOTE LISPSETQ) (GET (QUOTE SETQ) (QUOTE FSUBR)) (QUOTE FSUBR)) L))
MACRO)

(DEFPROP SETQ
 (LAMBDA(SETQ-L)
  (PROG	(SETQ-TMP)
	(RETURN
	 (COND ((EQ (CAR (LISPSETQ SETQ-TMP (GET (CADR SETQ-L) (QUOTE VALUE)))) (QUOTE GEMVAL))
		(RPLACA SETQ-L (QUOTE GEMSETQ)))
	       (SETQ-TMP (RPLACA SETQ-L (QUOTE LISPSETQ)))
	       ((GEMFIX (CADR SETQ-L)) (RPLACA SETQ-L (QUOTE GEMSETQ)))
	       (T (RPLACA SETQ-L (QUOTE LISPSETQ)))))))
MACRO)

(DEFPROP *ERRORX
 (LAMBDA NIL (PROG2 (PUTPROP (QUOTE *ERRORX) (GET (QUOTE ERRORX) (QUOTE SUBR)) (QUOTE SUBR)) (*ERRORX)))
EXPR)

(DEFPROP GEMFIX
 (LAMBDA(L)
  (COND	((ATOM L)
	 (COND ((*GETSYM L)
		(PROG2 (LISPSETQ GEMVARS (ENTER L GEMVARS))
		       (PUTPROP
			L
			(CONS (QUOTE GEMVAL)
			      (CONS (CAR NIL)
				    (CONS (COND	((*LESS (ABS (EXAMINE (*GETSYM L))) 777777777) (QUOTE FIXNUM))
						(T (QUOTE FLONUM)))
					  (NUMVAL (*GETSYM L)))))
			(QUOTE VALUE))))
	       (T NIL)))
	((ATOM (CAR L))
	 (COND ((GETL (CAR L) (QUOTE (SUBR FSUBR LSUBR EXPR FEXPR MACRO))) NIL)
	       ((*GETSYM (CAR L))
		(PROG2 (SETQ GEMVARS (ENTER (CAR L) GEMVARS))
		       (PUTPROP (CAR L) (NUMVAL (*GETSYM (CAR L))) (QUOTE SUBR))))
	       (T NIL)))
	(T NIL)))
EXPR)

(DEFPROP LISP
 (LAMBDA NIL (PROG NIL LOOP (TERPRI) (PRINT (EVAL (READ))) (GO LOOP)))
EXPR)

(DEFPROP ERRORX
 (LAMBDA NIL
  (PROG	(ERRORX-LASTPOS)
	(RETURN
	 (COND ((AND (LISPSETQ ERRORX-LASTPOS (NEXTEV (SUB1 (STKSRCH (QUOTE ERRORX) (SPDLPT) NIL))))
		     (GEMFIX (SPDLRT ERRORX-LASTPOS)))
		(PROG2 (PRINT (QUOTE (EXTERNAL FOUND))) (SPREDO ERRORX-LASTPOS)))
	       (T (*ERRORX))))))
EXPR)

(DEFPROP GEMTOP
 (LAMBDA NIL (PRINC (QUOTE "GEOMED embedded in LISP")))
EXPR)

(COND ((ERRSET GEMVARS NIL) NIL) (T (SETQ GEMVARS NIL)))

(COMMENT (MODCHR (CHRVAL (QUOTE $)) (MODCHR (CHRVAL (QUOTE A)) NIL)))